PC-X 1997 October/pcx14_9710.iso/swag/files.swg/0096_File disk storage and retrieval program.pas

Pascal/Delphi Source File | 1996-11-29 | 14.4 KB | 512 lines

program CAT;

{$I-}

uses
   dos,
   files, { see end for this unit }
   crt;

type
   arraybuf = array[1..65535] of byte;
   buffer = ^arraybuf;
   chksum = file of searchrec;

procedure error(mess:string);
var
   code:integer;
begin
   code:= ioresult;
   writeln('ERROR:  ', mess);
   {writeln('ERROR CODE:  ', code);}
   halt(1);
end;

procedure delete(drive:char; var success:boolean);
   procedure recurse(tree:directory_tree; var success:boolean);
   var
      info:searchrec;
      buffer:text;
      success2:boolean;
      d:string[79];
   begin
      if tree <> nil then begin
      success2:= true;
      d:= tree^.dir;
         begin
            recurse(tree^.lower_dir, success2);
            tree:= tree^.next;
            success:= success and success2;
            recurse(tree, success2);
            success:= success and success2;
         end;
      chdir(d);
      findfirst('*.*', anyfile, info);
      while (doserror = 0) and (success) do
         begin
            if (info.name <> '.') and (info.name <> '..') then
               begin
                  assign(buffer, info.name);
                  case info.attr of
                     $10: rmdir(info.name);
                     $20: erase(buffer);
                  else
                     success:= false;
                  end;
               end;
            findnext(info);
         end;
   end;
   end;
var
   tree:directory_tree;
begin
   tree:= nil;
   chdir(drive+':\');
   fill_dirtree(drive+':\', tree);
   success:= true;
   recurse(tree, success);
end;

function DriveExist(drive:char):boolean;
var
   fileinfo:searchrec;
begin
   findfirst(drive+':\*.*', anyfile, fileinfo);
   if doserror = 3 then
      driveexist:= false
   else
      driveexist:= true;
end;

procedure work(max,done:longint);
begin
   write(100*(done/max):4:1, '% complete.');
   gotoxy(1, wherey);
end;

procedure help;
begin
   writeln('The Concatinator   Version 1.0   Copyright 1996 by Jack Neely');
   writeln('A large file disk storage and retrieval program.');
   writeln;
   writeln('Usage:   CAT s <storage drive> <filename>');
   writeln('         CAT r <storage dirve> <path>');
   writeln;
   writeln('Commands: ''s'' = Store   ''r'' = Retrive');
   writeln('Storage drive must be the disk drive to store or that a large file is');
   writeln('stored apon.  Specify a path where the file will be placed when');
   writeln('retriving a file.  Specify a filemane when storing a large file.');
   writeln;
   writeln('You can use this program to store those large files that are larger');
   writeln('than a single disk onto multiple disks.  Anything on the disk prior');
   writeln('to storage will be erased.  A checksum file will also be stored on the');
   writeln('first disk of each set.');
   writeln;
   writeln('The author can be reached at [e-mail]');
   writeln;
   halt(0);
end;

function num(d:char):word;
begin
   num:= ord(upcase(d)) - 64;
end;

function strn(a:integer):string;
var
   s:string;
   i:integer;
begin
   str(a, s);
   if length(s) < 4 then
      for i:= 1 to 4 - length(s) do
         s:= '0' + s;
   strn:= s;
end;

function return(s:string; b:boolean):integer;
var
   str:string;
   i, c:integer;
begin
   str:= '';
   if b then
      for i:= 1 to 4 do
         str:= str + s[i]
   else
      for i:= 5 to 8 do
         str:= str + s[i];
   val(str, i, c);
   return:= i;
end;

procedure store(filename:string; drive:char);
var
   input, output:file;
   fileinfo, test:searchrec;
   filedata:chksum;
   c, full, disk:longint;
   diskdone:boolean;
   fset, disknum:word;
   success:boolean;
   data:buffer;
   buffersize, readcount, writecount:word;
   ch:char;
begin
   findfirst(filename, anyfile, fileinfo);
   if doserror <> 0 then
      error('File not found: ' + filename);
   new(data);
   c:= 0;
   disknum:= 0;
   diskdone:= true;
   if not DriveExist(drive) then error(drive+': does not exist.');
   randomize;
   fset:= random(9999);
   writeln('This is file set number ', fset, '.');
   assign(input, filename);
   reset(input, 1);
   while c < fileinfo.size do
      begin
         if diskdone then
            begin
               if disknum <> 0 then
                  close(output);
               clreol;
               disk:= 0;
               disknum:= disknum + 1;
               write('Insert disk ', disknum, ' and press [ENTER].');
               readln;
               diskdone:= false;
               buffersize:= sizeof(arraybuf);
               full:= disksize(num(drive));
               if disknum = 1 then
                  begin
                     writeln('Approximately ', (1+(fileinfo.size div disksize(num(drive)))), ' of these disks are needed.');
                     write('Continue? (Y/N)');
                     ch:= readkey;
                     if not ((ch = 'y') or (ch = 'Y')) then
                        halt(0);
                     writeln;
                  end;
               if disksize(num(drive)) <> diskfree(num(drive)) then
                  begin
                     findfirst(drive+':\*.cat', anyfile, test);
                     if return(test.name, true) = fset then
                        error('This disk is of this same set.');
                     delete(drive, success);
                     if not success then
                        error('Some existing file(s) on destination disk could not be removed.');
                  end;
                  assign(output, drive+':\'+strn(fset)+strn(disknum)+'.cat');
                  rewrite(output, 1);
               if disknum = 1 then
                  begin
                     assign(filedata, drive+':\check.sum');
                     rewrite(filedata);
                     write(filedata, fileinfo);
                     close(filedata);
                     full:= diskfree(num(drive));
                  end;
            end;
         if full - disk < buffersize then
            begin
               buffersize:= full - disk;
               diskdone:= true;
            end;
         blockread(input, data^, buffersize, readcount);
         if ioresult <> 0 then
            error('Errors on source disk.');
         blockwrite(output, data^, readcount, writecount);
         if ioresult <> 0 then
            error('Errors on target disk.');
         c:= c + readcount;
         disk:= disk + readcount;
         work(fileinfo.size, c);
         if readcount <> writecount then error('Unable to write to disk');
      end;
   clreol;
   close(input);
   close(output);
   dispose(data);
end;

procedure retrive(drive:char; path:string);
var
   setnum, disknum:word;
   diskdone, complete:boolean;
   newfile, store:file;
   cs:chksum;
   fileinfo, data:searchrec;
   d:buffer;
   c:longint;
   buffersize, readcount, writecount:word;
begin
   complete:= false;
   chdir(path);
   new(d);
   c:= 0;
   if ioresult <> 0 then
      error(path+' does not exist.');
   diskdone:= true;
   disknum:= 0;
   while not complete do
      begin
         if diskdone then
            begin
               clreol;
               disknum:= disknum + 1;
               if disknum > 1 then
                  close(store);
               diskdone:= false;
               write('Insert disk ', disknum, ' and press [ENTER].');
               readln;
               buffersize:= sizeof(arraybuf);
               if disknum = 1 then
                  begin
                     assign(cs, drive+':\check.sum');
                     reset(cs);
                     if ioresult <> 0 then error('No check sum file.');
                     read(cs, fileinfo);
                     close(cs);
                     assign(newfile, fileinfo.name);
                     rewrite(newfile, 1);
                     findfirst(drive+':\*.cat', archive, data);
                     if doserror = 18 then
                        begin
                           close(newfile);
                           erase(newfile);
                           error('Disk does not contain storage data.');
                        end;
                     assign(store, drive+':\'+data.name);
                     reset(store, 1);
                     setnum:= return(data.name, true);
                     if return(data.name, false) <> disknum then
                        begin
                           close(newfile);
                           erase(newfile);
                           error('Wrong disk.');
                        end;
                     writeln('File set number is: ', setnum);
                  end
               else
                  begin
                     findfirst(drive+':\*.cat', archive, data);
                     if doserror = 18 then
                        begin
                           close(newfile);
                           erase(newfile);
                           error('Disk does not contain storage data.');
                        end;
                     assign(store, drive+':\'+data.name);
                     reset(store, 1);
                     if setnum <> return(data.name, true) then
                        begin
                           close(newfile);
                           erase(newfile);
                           error('Disk is of a different set.');
                        end;
                     if disknum <> return(data.name, false) then
                        begin
                           close(newfile);
                           erase(newfile);
                           error('Wrong disk.');
                        end;
                  end;
            end;
         blockread(store, d^, buffersize, readcount);
         if ioresult <> 0 then
            begin
               close(newfile);
               erase(newfile);
               error('Errors on source disk.');
            end;
         blockwrite(newfile, d^, readcount, writecount);
         if ioresult <> 0 then
            begin
               close(newfile);
               erase(newfile);
               error('Errors on target disk.');
            end;
         c:= c + readcount;
         if writecount <> readcount then
            begin
               close(newfile);
               erase(newfile);
               error('Unable to write to disk.');
            end;
         if buffersize <> readcount then
            diskdone:= true;
         if fileinfo.size = c then complete:= true;
         work(fileinfo.size, c);
      end;
   clreol;
   close(newfile);
   close(store);
   dispose(d);
end;

var
   c1, c2:string;

begin
   if paramcount = 0 then
      help;
   if paramcount <> 3 then
      error('Incorect number of parameters.');
   c1:= paramstr(1);
   c2:= paramstr(2);
   case c1[1] of
      's', 'S' : store(paramstr(3), c2[1]);
      'r', 'R' : retrive(c2[1], paramstr(3));
   else
      error('Incorect parameters.');
   end;
   writeln('Complete!');
end.

{ ---------------  CUT ---------------- }

unit files;

interface

uses
   dos;

type
   filetype = string[12];
   {searchrec = record    This is how searchrec is defined in the DOS unit.
      Fill: array[1..21] of Byte;
      Attr: Byte;
      Time: Longint;
      Size: Longint;
      Name: string[12];
   end;  }
   filestack = ^ node;
   node = record
      fileinfo:searchrec;
      next:filestack;
   end;
   directory_tree = ^dnode;
   dnode = record
      dir:string;
      lower_dir:directory_tree;
      next:directory_tree;
   end;

procedure fill_filestack(var stack:filestack);
   {Fills stack of type filestack with all the file enteries in the
   current directory.  Includes directoies and hidden file types.}

procedure push_filestack(var stack:filestack; item:searchrec);
   {Pushes in alfa order a new node on a filestack.}

procedure fill_dirtree(dir:string; var tree:directory_tree);
   {Fills a tree sturcture with the directory structure using dir string
   as the root.}

implementation

procedure push_filestack(var stack:filestack; item:searchrec);
var
   temp:filestack;

   procedure insert(var stack, prev:filestack);
   begin
      if (stack = nil) then
         begin
            temp^.next:= stack;
            stack:= temp;
         end
      else
         if temp^.fileinfo.name > stack^.fileinfo.name then
            insert(stack^.next, stack)
         else
            if temp^.fileinfo.name < stack^.fileinfo.name then
               begin
                  if prev = stack then
                     begin
                        temp^.next:= stack;
                        stack:= temp;
                     end
                  else
                     begin
                        temp^.next:= stack;
                        prev^.next:= temp;
                     end;
               end;
   end;
begin
   new(temp);
   temp^.fileinfo:= item;
   insert(stack, stack);
end;

procedure fill_filestack(var stack:filestack);
var
   dirinfo:searchrec;
begin
   findfirst('*.*', anyfile, dirinfo);
   while doserror <> 18 do
      begin
         push_filestack(stack, dirinfo);
         findnext(dirinfo);
      end;
end;

procedure push(var head:directory_tree; item:string);
var
   temp:directory_tree;
begin
   new(temp);
   temp^.dir:= item;
   temp^.next:= head;
   head:= temp;
   head^.lower_dir:= nil;
end;

procedure fill_dirtree(dir:string; var tree:directory_tree);
procedure fill_dirlist(var head:directory_tree; directory:string; s:integer);
var
   place:directory_tree;
   dirinfo:searchrec;
   found:boolean;
begin
   writeln(directory);
   chdir(directory);
   findfirst('*.*', 16, dirinfo);
   while doserror = 0 do
      begin
         if (dirinfo.attr = 16) and ((dirinfo.name <> '..') and (dirinfo.name <> '.'))then
            begin
               push(head, fexpand(dirinfo.name));
               found:= true;
            end;
            findnext(dirinfo);
         end;
      if found then
         begin
            place:= head;
            while place <> nil do
               begin
                  fill_dirlist(place^.lower_dir, place^.dir, s+3);
                  place:= place^.next;
               end;
         end;
end;

var
   temp:directory_tree;
begin
   tree:= nil;
   fill_dirlist(tree, dir, 0);
   new(temp);
   temp^.dir:= dir;
   temp^.lower_dir:= tree;
   temp^.next:= nil;
   tree:= temp;
end;

end.